home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
rbbs_pc
/
mpl17ds.zip
/
RBBSSUB1.BAS
< prev
next >
Wrap
BASIC Source File
|
1989-06-14
|
73KB
|
2,033 lines
' $LINESIZE:132
' $title: 'RBBS-SUB1.BAS CPC17-1D, Copyright 1986-89 by D. Thomas Mack'
' Copyright 1987 by D. Thomas Mack, all rights reserved.
' Name ...............: RBBSSUB1.BAS
' Written by .........: D. Thomas Mack
' First Released .....: September 18, 1988
' Subsequent Releases.: OCT 30 1988
' Copyright ..........: 1986, 1987, 1988
' Purpose.............:
' Subprorams that require error trapping are incorporated
' within RBBSSUB1.BAS as separately callable subroutines
' in order to free up as much code as possible within
' the 64K code segment used by RBBS-PC.BAS.
' Parameters..........: Most parameters are passed via a COMMON statement.
'
' Subroutine Line Function of Subroutine
' Name Number
' CHANGEDIR 20103 Change subdirectory
' CHECKINT 58360 Check input is valid integer
' FINDFREE 52000 Find amount of space on the upload disk drive
' FINDIT 20221 Find if a file exists on a device
' FINDUSER 12610 Find a user in the USERS file
' FLUSHCOM 20311 Read all characters in the communications port
' GETCOM 1420 Read a character from the communications port
' GETPASWD 58280 Read RBBS-PC's "PASSWORD" file
' GETWRK 58330 Read record from file number 2
' KILLWORK 58260 Delete a RBBS-PC "WORK" file
' NETBIOS 29900 Lock/Unlock NETBIOS semaphore files
' OPENCOM 200 Open communications port (number 3)
' OPENFMS 58190 Open the upload management system directory
' OPENOUTW 28220 Open RBBS-PC's "WORK" file (number 2) for output
' OPENRSEQ 1479 Open a sequential file (number 2) for random I/O
' OPENUSER 9400 Open the USER file (number 5)
' OPENWORK 58000 Open RBBS-PC's work file (number 2)
' OPENWRKA 58340 Open RBBS-PC's "WORK" file (number 2) for append
' PRINTIT 13674 Print line on the local PC running RBBS-PC printer
' PRINTWRK 58320 Print string to file #2 w/o CR/LF
' PRNTWRKA 58350 Print string to file #2 with CR/LF
' PUTCOM 59650 Write to the communications port
' PUTWORK 59660 Write to work file randomly
' READANY 58310 Read file number 2 into A$
' READDEF 117 Read configuration file
' READDIR 58290 Read entire lines
' READPARMS 58300 Read certain number of parameters from file 2
' SETCALL 108 Find where next callers record is
' UPDATEC 43050 Update the caller's file with elasped session time
' UPDTCALR 13665 Update to the caller's file
'
' $INCLUDE: 'RBBS-VAR.BAS'
'
' $SUBTITLE: 'SETCALL - subroutine to find last callers rec'
' $PAGE
'
' SUBROUTINE NAME -- SETCALL
'
' INPUT PARAMETERS -- PARAMETER MEANING
'
' OUTPUT PARAMETERS -- CALLERS.FILE.INDEX!
'
' SUBROUTINE PURPOSE -- TO FIND WHERE TO LEAVE OFF ON CALLERS FILE
'
108 SUB SETCALL STATIC
ON ERROR GOTO 65000
IF PREV.CALLERS$ = CALLERS.FILE$ OR CALLERS.FILE.PREFIX$ = "" THEN _ 'KG102505
EXIT SUB
PREV.CALLERS$ = CALLERS.FILE$
CALLERS.FILE.INDEX! = 1
CLOSE 2
CLOSE 4
IF SHARE.IT THEN _
OPEN CALLERS.FILE$ FOR RANDOM SHARED AS #4 LEN=64 _ ' KG102505
ELSE OPEN "R",4,CALLERS.FILE$,64
FIELD 4,64 AS CALLERS.RECORD$
IF LOF(4) > 0 THEN _ ' KG102505
CALLERS.FILE.INDEX! = LOF(4) / 64
IF CALLERS.FILE.INDEX! < 1 THEN _
CALLERS.FILE.INDEX! = 0
B$ = STRING$(13,0)
110 GET 4,CALLERS.FILE.INDEX!
IF EC > 0 THEN _
EC = 0 : _
CALLERS.FILE.INDEX! = 0 : _
EXIT SUB
IF LEFT$(CALLERS.RECORD$,13) = B$ THEN _
CALLERS.FILE.INDEX! = CALLERS.FILE.INDEX! - 1 : _
GOTO 110
END SUB
'
' $SUBTITLE: 'READDEF - subroutine to read RBBS-PC.DEF file'
' $PAGE
'
' SUBROUTINE NAME -- READDEF
'
' INPUT PARAMETERS -- PARAMETER MEANING
' CONFIG.FILENAME$ NAME OF RBBS-PC.DEF FILE
' SUBROUTINE.PARAMETER = -62 ONLY READ THE .DEF FILE
'
' OUTPUT PARAMETERS -- ALL THE RBBS-PC.DEF PARAMETERS
'
' SUBROUTINE PURPOSE -- TO READ THE PARAMETERS FROM THE RBBS-PC.DEF FILE
SUB READDEF (CONFIG.FILE$) STATIC
ON ERROR GOTO 65000
'
' **** OPEN AND READ RBBS-PC CONFIGURATION DEFINITIONS ****
'
117 IF SUBROUTINE.PARAMETER <> -62 THEN _
IF PREV.READ$ = CONFIG.FILE$ THEN _
EXIT SUB _
ELSE PREV.READ$ = CONFIG.FILE$
CLOSE 2
BULLETIN.SAVE$ = BULLETIN.MENU$
CALL OPENWORK (CONFIG.FILE$) ' LP102201
CURRENT.DEF$ = CONFIG.FILE$
INPUT #2,DF$, _
DOWNLOAD.DRIVES$, _
SYSOP.PASSWORD.1$, _
SYSOP.PASSWORD.2$, _
SYSOP.FIRST.NAME$, _
SYSOP.LAST.NAME$, _
REQUIRED.RINGS, _
START.OFFICE.HOURS, _
END.OFFICE.HOURS, _
MINUTES.PER.SESSION!, _
DF, _
DF, _
UPLOAD.DIRECTORY$, _
EXPERT.USER, _
ACTIVE.BULLETINS, _
PROMPT.BELL, _
DF, _
MENUS.CAN.PAUSE, _
MENU$(1), _
MENU$(2), _
MENU$(3), _
MENU$(4), _
MENU$(5), _
MENU$(6), _
CONFERENCE.MENU$, _
DF, _
WELCOME.INTERRUPTABLE, _
REMIND.FILE.TRANSFERS, _
PAGE.LENGTH, _
MAX.MESSAGE.LINES.DEF, _
DOORS.AVAILABLE, _
DF$, _ ' KG120501
MAIN.MESSAGE.FILE$, _ ' KG120501
MAIN.MESSAGE.BACKUP$ ' KG120501
INPUT #2, X$, _
COMMENTS.FILE$, _
MAIN.USER.FILE$, _
WELCOME.FILE$, _
NEWUSER.FILE$, _
MAIN.DIRECTORY.EXTENTION$
CALL BRKFNAME (X$,Y$,DF$,Z$,FALSE) ' KG102705
IF DF$ <> "" THEN _ ' KG102705
CALLERS.FILE$ = X$
IF CONFERENCE.MODE THEN _
INPUT #2, DF$ _
ELSE INPUT #2, COM.PORT$
INPUT #2, BULLETINS.OPTIONAL, _
MODEM.INIT.COMMAND$, _
RTS$, _
DF, _
FG, _
BG, _
BORDER
IF CONFERENCE.MODE THEN _
INPUT #2, DF$, _
DF$ _
ELSE INPUT #2, RBBS.BAT$ , _
RCTTY.BAT$
INPUT #2,OMIT.MAIN.DIRECTORY$, _
FIRST.NAME.PROMPT$, _
HELP$(3), _
HELP$(4), _
HELP$(7), _
HELP$(9), _
BULLETIN.MENU$, _
BULLETIN.PREFIX$, _
DF$, _
MESSAGE.REMINDER, _
REQUIRE.NON.ASCII, _
ASK.EXTENDED.DESC, _
MAXIMUM.NUMBER.OF.NODES, _
NETWORK.TYPE, _
RECYCLE.TO.DOS, _
DF, _
DF, _
TRASHCAN.FILE$
INPUT #2,MINIMUM.LOGON.SECURITY, _
DEFAULT.SECURITY.LEVEL, _
SYSOP.SECURITY.LEVEL, _
FILESEC.FILE$, _
SYSOP.MENU.SECURITY.LEVEL, _
CONFMAIL.LIST$, _
MAXIMUM.VIOLATIONS, _
OPT.SEC(50), _ ' SECURITY FOR SYSOP COMMANDS 1
OPT.SEC(51), _
OPT.SEC(52), _
OPT.SEC(53), _
OPT.SEC(54), _
OPT.SEC(55), _
OPT.SEC(56), _ ' SYSOP 7
PASSWORDS.FILE$, _
MAXIMUM.PASSWORD.CHANGES, _
MINIMUM.SECURITY.FOR.TEMP.PASSWORD, _
OVERWRITE.SECURITY.LEVEL, _
DOORS.TERMINAL.TYPE, _
MAX.PER.DAY
INPUT #2,OPT.SEC(1), _ ' SECURITY FOR MAIN MENU COMMANDS 1
OPT.SEC(2), _
OPT.SEC(3), _
OPT.SEC(4), _
OPT.SEC(5), _
OPT.SEC(6), _
OPT.SEC(7), _
OPT.SEC(8), _
OPT.SEC(9), _
OPT.SEC(10), _
OPT.SEC(11), _
OPT.SEC(12), _
OPT.SEC(13), _
OPT.SEC(14), _
OPT.SEC(15), _
OPT.SEC(16), _
OPT.SEC(17), _
OPT.SEC(18), _ ' MAIN COMMAND 18
MIN.NEWCALLER.BAUD, _
WAIT.BEFORE.DISCONNECT
INPUT #2,OPT.SEC(19), _ ' Security for FILE COMMANDS 1
OPT.SEC(20), _
OPT.SEC(21), _
OPT.SEC(22), _
OPT.SEC(23), _
OPT.SEC(24), _
OPT.SEC(25), _
OPT.SEC(26), _ ' FILE COMMAND 8
OPT.SEC(27), _ ' SECURITY FOR UTILITY COMMANDS 1
OPT.SEC(28), _
OPT.SEC(29), _
OPT.SEC(30), _
OPT.SEC(31), _
OPT.SEC(32), _
OPT.SEC(33), _
OPT.SEC(34), _
OPT.SEC(35), _
OPT.SEC(36), _
OPT.SEC(37), _
OPT.SEC(38), _ ' UTIL COMMAND 12
OPT.SEC(46), _ ' SECURITY FOR GLOBAL COMMANDS 1
OPT.SEC(47), _
OPT.SEC(48), _
OPT.SEC(49), _ ' GLOBAL 4
UPLOAD.TIME.FACTOR!, _
COMPUTER.TYPE, _
REMIND.PROFILE, _
RBBS.NAME$, _
COMMANDS.BETWEEN.RINGS, _
MNP.SUPPORT, _
PAGING.PRINTER.SUPPORT$, _
MODEM.INIT.BAUD$
IF EC > 0 THEN _
EXIT SUB
118 INPUT #2, TURN.PRINTER.OFF,_ ' Turn printer off each recycle
DIRECTORY.PATH$, _ ' Where dir files are stored
MIN.SEC.TO.VIEW, _
LIMIT.SEARCH.TO.FMS, _
DEFAULT.CATEGORY.CODE$, _
DIR.CATEGORY.FILE$, _
NEW.FILES.CHECK, _
MAX.DESC.LEN, _
SHOW.SECTION, _
COMMANDS.IN.PROMPT, _
NEWUSER.SETS.DEFAULTS, _
HELP.PATH$, _
HELP.EXTENSION$, _
MAIN.COMMANDS$, _
FILE.COMMANDS$, _
UTIL.COMMANDS$, _
GLOBAL.COMMANDS$, _
SYSOP.COMMANDS$
INPUT #2, RECYCLE.WAIT, _
OPT.SEC(39), _ ' SECURITY FOR LIBRARY COMMANDS 1
OPT.SEC(40), _
OPT.SEC(41), _
OPT.SEC(42), _
OPT.SEC(43), _
OPT.SEC(44), _
OPT.SEC(45), _ ' LIBRARY COMMANDS 7
LIBRARY.DRIVE$, _
LIBRARY.DIRECTORY.PATH$, _
LIBRARY.DIRECTORY.EXTENTION$, _
LIBRARY.WORK.DISK.PATH$, _
LIBRARY.MAX.DISK, _
LIBRARY.MAX.DIRECTORY, _
LIBRARY.MAX.SUBDIR, _
LIBRARY.SUBDIR.PREFIX$, _
LIBRARY.ARCHIVE.PATH$, _
LIBRARY.ARCHIVE.PROGRAM$, _
LIBRARY.COMMANDS$
'
' ***** ESTABLISH COMMUNICATION PORT REGISTERS AND COMMANDS ****
' ***** GET DOS SUB-DIRECTORY RBBS-PC OPTIONS ****
'
INPUT #2, UPLOAD.PATH$, _ ' Where upl dir goes
MAIN.FMS.DIRECTORY$, _ ' Shared dir in FMS
ANS.MENU$, _
REQUIRED.QUESTIONNAIRE$,_
REMEMBER.NEW.USERS,_
SURVIVE.NOUSER.ROOM,_
PROMPT.HASH$,_
START.HASH,_
LEN.HASH,_
PROMPT.INDIV$,_
START.INDIV,_
LEN.INDIV
INPUT #2, BYPASS.MSGS, _
MUSIC, _
RESTRICT.BY.DATE, _
DAYS.TO.WARN, _
DAYS.IN.REGISTRATION.PERIOD, _
CALLBACK.VERIFICATION, _
RESTRICT.VALID.CMDS, _
NEW.USER.DEFAULT.MODE, _
NEW.USER.LINE.FEEDS, _
ARKVIEW.PATH$, _
NEW.USER.BELL, _
NEW.USER.CASE, _
NEW.USER.MARGINS, _
WRAP.CALLERS.FILE$, _
REDIRECT.IO.METHOD, _
GO.TO.SHELL, _
HALT.ON.ERROR, _
NEW.PUBLIC.MSGS.SECURITY, _
NEW.PRIVATE.MSGS.SECURITY, _
SECURITY.NEEDED.TO.CHANGE.MSGS, _
SL.CATEGORIZE.UPLOADS, _
BAUDOT, _
TIME.TO.DROP.TO.DOS, _
EXPIRED.SECURITY, _
DTR.DROP.DELAY, _
ASK.IDENTITY, _
USE.EXTERNAL.XMODEM, _
BUFFER.SIZE, _
MLCOM, _
SHOOT.YOURSELF, _
F7.MESSAGE$, _
NEW.USER.DEFAULT.PROTOCOL$, _
NEW.USER.GRAPHICS$, _
NET.MAIL$, _
MASTER.DIRECTORY.NAME$, _
PROTO.DEF$, _
UPCAT.HELP$, _
ALWAYS.STREW.TO$, _
LAST.NAME.PROMPT$
INPUT #2, PERSONAL.DRVPATH$, _
PERSONAL.DIR$, _
PERSONAL.BEGIN, _
PERSONAL.LEN, _
PERSONAL.PROTOCOL$, _
PERSONAL.CONCAT , _
PRIVATE.READ.SEC, _
PUBLIC.READ.SEC, _
SEC.CHANGE.MSG, _
KEEP.INIT.BAUD, _
MAIN.PUI$ ' KG110504
IF CONFERENCE.MODE THEN _ ' KG110504
INPUT #2, DF$,DF$,DF$ _ ' KG110504
ELSE INPUT #2, DEFAULT.ECHOER$, _ ' KG110504
HOST.ECHO.ON$, _ ' KG110504
HOST.ECHO.OFF$ ' KG110504
INPUT #2, SWITCH.BACK, _ Pe11/07/88
DEFAULT.LINE.ACK$, _
ALTDIR.EXTENSION$, _
DIRECTORY.PREFIX$
IF CONFERENCE.MODE THEN _
INPUT #2, DF, _
DF, _
DF _
ELSE INPUT #2, DF,_
MODEM.INIT.WAIT.TIME, _
MODEM.COMMAND.DELAY.TIME
INPUT #2, TURBO.RBBS, _
SUBDIR.COUNT, _
DF, _
UPLOAD.TO.SUBDIR, _
DF, _
UPLOAD.SUBDIR$, _
MIN.OLDCALLER.BAUD, _
USE.EXTERNAL.YMODEM, _
DISKFULL.GO.OFFLINE, _
EXTENDED.LOGGING
IF CONFERENCE.MODE THEN _
INPUT #2, DF$, _
DF$, _
DF$, _
DF$ _
ELSE INPUT #2, MODEM.RESET.COMMAND$, _
MODEM.COUNT.RINGS.COMMAND$, _
MODEM.ANSWER.COMMAND$, _
MODEM.GO.OFFHOOK.COMMAND$
INPUT #2,DISK.FOR.DOS$, _
DUMB.MODEM, _
COMMENTS.AS.MESSAGES
IF CONFERENCE.MODE THEN _
INPUT #2, DF, _
DF, _
DF, _
DF, _
DF, _
DF _
ELSE INPUT #2, LSB,_
MSB,_
LINE.CONTROL.REGISTER,_
MODEM.CONTROL.REGISTER,_
LINE.STATUS.REGISTER,_
MODEM.STATUS.REGISTER
INPUT #2,KEEP.TIME.CREDITS, _
XON.XOFF, _
ALLOW.CALLER.TURBO, _
USE.DEVICE.DRIVER$, _
PRELOG$, _
NEW.USER.QUESTIONNAIRE$, _
EPILOG$, _
REGISTRATION.PROGRAM$, _
QUES.PATH$, _
USER.LOCATION$, _
DF$, _
DF$, _
DF$, _
ENFORCE.UPLOAD.DOWNLOAD.RATIOS, _
SIZE.OF.STACK, _
SECURITY.EXEMPT.FROM.EPILOG, _
USE.BASIC.WRITES, _
DOSANSI, _
ESCAPE.INSECURE, _
USE.DIR.ORDER, _
ADD.DIR.SECURITY, _
MAX.EXTENDED.LINES, _
ORIG.COMMANDS$
INPUT #2,LOGON.MAIL.LEVEL$, _
MACRO.DRVPATH$, _
MACRO.EXTENSION$, _
EMPHASIZE.ON.DEF$, _
EMPHASIZE.OFF.DEF$, _
FG.1.DEF$, _
FG.2.DEF$, _
FG.3.DEF$, _
FG.4.DEF$, _
SECVIO.HLP$ ' KG101402
IF CONFERENCE.MODE THEN _ ' KG101402
INPUT #2,DF _ ' KG101402
ELSE INPUT #2,FOSSIL ' KG101402
INPUT #2,MAX.CARRIER.WAIT, _ ' KG101402
DF, _
SMART.TEXT, _
TIME.LOCK, _
WRITE.BUF.DEF, _
DF, _
DF, _
DF, _
AUTOPAGE.DEF$
IF EC > 0 THEN _
EXIT SUB
CONFIG.FILENAME$ = CONFIG.FILE$ ' KG121501
CALL EDITDEF
END SUB
' $SUBTITLE: 'OPENCOM - subroutine to open the communications port'
' $PAGE
'
' SUBROUTINE NAME -- OPENCOM
'
' INPUT PARAMETERS -- PARAMETER MEANING
' BAUD.RATE$ BAUD TO OPEN MODEM
' PARITY$ PARITY TO OPEN MODEM
'
' OUTPUT PARAMETERS -- BAUD.TEST BAUD RATE TO SET RS232 AT
'
' SUBROUTINE PURPOSE -- TO OPEN THE COMMUNICATIONS PORT.
'
SUB OPENCOM(BAUD.RATE$,PARITY$) STATIC
ON ERROR GOTO 65000
200 IF FOSSIL THEN _
IF RTS$ = "YES" THEN _
FLOW.CONTROL = TRUE : _
FLOW% = &H00F2 : _
CALL FOSFLOWCTL(COMPORT%,FLOW%)
IF INSTR(PARITY$,"N") THEN _
PARITY% = 2 : _ ' NO PARITY
DATABITS% = 3 : _ ' 8 DATA BITS
STOPBITS% = 0 _ ' 1 STOP BIT
ELSE PARITY% = 3 : _ ' EVEN PARITY
DATABITS% = 2 : _ ' 7 DATA BITS
STOPBITS% = 0 ' 1 STOP BIT
IF FOSSIL THEN _
COMSPEED% = VAL(BAUD.RATE$) : _
CALL FOSSPEED(COMPORT%,COMSPEED%,PARITY%,DATABITS%,STOPBITS%) : _
EXIT SUB
CLOSE 3
IF RTS$ = "YES" THEN _
FLOW.CONTROL = TRUE : _
X$ = ",CS26600,CD,DS" _
ELSE X$ = ",RS,CD,DS"
OPEN COM.PORT$ + ":" + BAUD.RATE$ + PARITY$ + X$ AS #3
'
' *****************************************************************************
' * RAISE THE RTS SIGNAL IF THE MODEM USES RTS FOR MODEM FLOW CONTROL (ONCE *
' * IT IS RAISED, IT WILL STAY UP UNTIL THE REGISTER IS CLEARED OUT). *
' *****************************************************************************
'
END SUB
' $SUBTITLE: 'GETCOM -- subroutine reads a char. from comm. port'
' $PAGE
'
' SUBROUTINE NAME -- GETCOM
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STNG$ STRING TO READ A CHARACTER INTO FROM
' THE COMMUNICATIONS PORT (FILE #3)
'
' OUTPUT PARAMETERS -- STNG$
'
' SUBROUTINE PURPOSE -- READS A CHARACTER FROM FROM THE COMMUNICATIONS PORT.
'
SUB GETCOM (STRNG$) STATIC
ON ERROR GOTO 65000
1420 IF FOSSIL THEN _
CALL FOSRXCHAR(COMPORT%,CHAR%) : _
STRNG$ = CHR$(CHAR%) _
ELSE STRNG$ = INPUT$(1,3)
1421 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 1420
END SUB
' $SUBTITLE: 'OPENRSEQ - subroutine open sequential file randomly'
' $PAGE
'
' SUBROUTINE NAME -- OPENRSEQ
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILNAME$ NAME OF SEQUENTIAL FILE TO OPEN AS #2
'
' OUTPUT PARAMETERS -- NUM.RECS NUMBER OF 128-BYTE RECORDS IN THE FILE
' LEN.LAST.REC NUMBER OF BYTES IN THE LAST RECORD (IT
' MAY BE LESS THAN OR EQUAL TO 128).
'
' SUBROUTINE PURPOSE -- SUBROUTINE TO OPEN A SEQUENTIAL FILE AS FILE # 2 AND
' READ IT RANDOMLY.
'
SUB OPENRSEQ (FILNAME$,NUM.RECS,LEN.LAST.REC,REC.LEN) STATIC
1479 ON ERROR GOTO 65000
CLOSE 2
1480 EC = 0
1481 IF SHARE.IT THEN _
OPEN FILNAME$ FOR RANDOM SHARED AS #2 LEN=REC.LEN _
ELSE OPEN "R",2,FILNAME$,REC.LEN
IF EC = 52 THEN _
GOTO 1480
FIELD #2, REC.LEN AS DOWNLOAD.RECORD$
I# = LOF(2)
NUM.RECS = FIX(I#/REC.LEN)
LEN.LAST.REC = I# - CDBL(NUM.RECS) * REC.LEN
IF LEN.LAST.REC > 0 THEN _
NUM.RECS = NUM.RECS + 1 _
ELSE LEN.LAST.REC = REC.LEN
END SUB
' $SUBTITLE: 'OPENUSER - subroutine to open the users file as #5'
' $PAGE
'
' SUBROUTINE NAME -- OPENUSER
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SHARE.IT
'
' OUTPUT PARAMETERS -- ACTIVE.USER.FILE$
' CITY.STATE$
' ELAPSED.TIME$
' LAST.DATE.TIME.ON$
' LAST.REC # OF LAST RECORD IN USERS FILE
' LIST.NEW.DATE$
' MACHINE.TYPE$
' PASSWORD$
' SECURITY.LEVEL$
' USER.DOWNLOADS$
' USER.NAME$
' USER.OPTIONS$
' USER.RECORD$
' USER.UPLOADS$
'
' SUBROUTINE PURPOSE -- OPEN THE USER FILE AS FILE # 5
'
SUB OPENUSER (LAST.REC) STATIC
ON ERROR GOTO 65000
'
' **** OPEN AND DEFINE USER FILE RECORD VARIABLES **** *
'
9400 CLOSE 5
IF SHARE.IT THEN _
OPEN ACTIVE.USER.FILE$ FOR RANDOM SHARED AS #5 LEN=128 _
ELSE OPEN "R",5,ACTIVE.USER.FILE$,128
I# = LOF(5)
LAST.REC = FIX(I#/128)
FIELD 5,31 AS USER.NAME$, _
15 AS PASSWORD$, _
2 AS SECURITY.LEVEL$, _
14 AS USER.OPTIONS$, _
24 AS CITY.STATE$, _
3 AS MACHINE.TYPE$, _
4 AS TODAY.DL$, _
4 AS TODAY.BYTES$, _
4 AS DL.BYTES$, _
4 AS UL.BYTES$, _
14 AS LAST.DATE.TIME.ON$, _
3 AS LIST.NEW.DATE$, _
2 AS USER.DOWNLOADS$, _
2 AS USER.UPLOADS$, _
2 AS ELAPSED.TIME$
FIELD 5,128 AS USER.RECORD$
END SUB
' $SUBTITLE: 'FINDUSER - subroutine to search users file for a name'
' $PAGE
'
' SUBROUTINE NAME -- FINDUSER
'
' INPUT PARAMETERS -- PARAMETER MEANING
' HASH.TO.LOOK.FOR$ STRING TO SEARCH FOR IN USERS
' INDIV.TO.LOOK.FOR$ STRING TO USE TO INDIVIDUATE
' USERS WITH SAME HASH
' START.HASH.POS WHERE HASH FIELD STARTS IN THE
' "USERS" FILE
' LEN.HASH.FIELD LENGTH OF THE HASH FIELD
' START.INDIV.POS WHERE THE FIELD TO DISTINGUISH
' AMONG USERS (I.E. WITH THE SAME
' NAME) STARTS IN THE "USERS" FILE
' (SET TO 0 IF NONE TO BE USED)
' LEN.INDIV.FIELD LENGTH OF FIELD TO DISTINGUISH
' AMONG USERS
' MAX.POSITION HIGHEST RECORD TO SEARCH OR USE
'
' NOTE: THIS SUBROUTINE ASSUMES THE "USERS" FILE IS OPEN AS FILE 2.
'
' OUTPUT PARAMETERS -- WHETHER.FOUND SET TO "TRUE" IF USER WAS FOUND
' OTHERWISE IT IS "FALSE"
' POS.TO.USE NUMBER OF THE "USERS" RECORD THAT
' BELONGS TO THE USER (IF FOUND) OR
' TO USE FOR THE USER (IF THE USER
' WASN'T FOUND)
' POS.TO.RECLAIM SET TO 0 IF THE RECORD NUMBER
' SELECTED FOR THIS USER HAS NEVER
' BEEN USED.
'
' SUBROUTINE PURPOSE -- TO SEARCH THE "USERS" FILE AND DETERMINE THE RECORD
' NUMBER TO USE FOR THE CALLER IN THE "USERS" FILE.
'
SUB FINDUSER (HASH.TO.LOOK.FOR$,INDIV.TO.LOOK.FOR$,START.HASH.POS,_
LEN.HASH.FIELD,START.INDIV.POS,LEN.INDIV.FIELD,_
MAX.POSITION,WHETHER.FOUND,_
POS.TO.USE,POS.TO.RECLAIM) STATIC
ON ERROR GOTO 65000
EC = 0
WHETHER.FOUND = 0
IF HASH.TO.LOOK.FOR$ = SPACE$(LEN(HASH.TO.LOOK.FOR$)) THEN _
EXIT SUB
EMPTY.REC$ = SPACE$(LEN.HASH.FIELD)
EMPTY.INDIV$ = SPACE$(LEN.INDIV.FIELD)
NEWUSER$ = LEFT$("NEWUSER ",LEN.HASH.FIELD + 2)
FIELD 5, 128 AS FILLER$
X$ = HASH.TO.LOOK.FOR$ + SPACE$(LEN.HASH.FIELD - LEN(HASH.TO.LOOK.FOR$))
CALL HASHRBBS (HASH.TO.LOOK.FOR$,MAX.POSITION,POS.TO.USE,DF)
12600 Y$ = INDIV.TO.LOOK.FOR$ + SPACE$(LEN.INDIV.FIELD - LEN(INDIV.TO.LOOK.FOR$))
POS.TO.RECLAIM = 0
12610 GET 5,POS.TO.USE
IF EC > 0 THEN _
IF EC = 63 THEN _
EC = O : _
GOTO 12621 _
ELSE EC = 0 : _
GOTO 12620
HASH.VALUE$ = MID$(FILLER$,START.HASH.POS,LEN.HASH.FIELD)
IF X$ = HASH.VALUE$ THEN _
IF START.INDIV.POS < 1 THEN _
WHETHER.FOUND = TRUE : _
GOTO 12622 _
ELSE INDIV.VALUE$ = MID$(FILLER$,START.INDIV.POS,LEN.INDIV.FIELD) : _
IF Y$ = INDIV.VALUE$ OR INDIV.VALUE$ = EMPTY.INDIV$ THEN _
WHETHER.FOUND = TRUE : _
GOTO 12622
IF HASH.VALUE$ = EMPTY.REC$ THEN _
POS.TO.USE = POS.TO.RECLAIM - (POS.TO.RECLAIM = 0) * POS.TO.USE : _
WHETHER.FOUND = FALSE : _
GOTO 12622
IF ASC(HASH.VALUE$) = 0 OR INSTR(HASH.VALUE$,NEWUSER$) = 1 THEN _
IF POS.TO.RECLAIM = 0 THEN _
POS.TO.RECLAIM = POS.TO.USE
12620 POS.TO.USE = POS.TO.USE + DF
IF POS.TO.USE > MAX.POSITION - 1 THEN _
POS.TO.USE = POS.TO.USE - MAX.POSITION
GOTO 12610
12621 IF POS.TO.RECLAIM = 0 THEN _
POS.TO.RECLAIM = POS.TO.USE
GOTO 12620
12622 END SUB
' $SUBTITLE: 'UPDTCALR - subroutine to write to CALLERS file'
' $PAGE
'
' SUBROUTINE NAME -- UPDTCALR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' ERRMES$ MESSAGE TO GO IN CALLER LOG
' EXT.LOG = 1 CHECK FOR EXTENDED LOGGING
' BEFORE UPDATING.
' = 2 UPDATE CALLER LOG WITH Z$
'
' OUTPUT PARAMETERS -- CURRENT.DATE$ CURRENT DATE (MM-DD-YY)
' TIM$ CURRENT TIME (I.E. 1:13 PM)
' TIME.LOGGEND.ON$ TIME USER LOGGED ON (HH:MM:SS)
'
' SUBROUTINE PURPOSE -- TO UPDATE THE CALLER'S FILE AND/OR PRINT ON THE
' LOCAL PRINTER IF IT IS ENABLED
'
SUB UPDTCALR (ERRMES$,EXT.LOG) STATIC
ON ERROR GOTO 65000
IF CALLERS.FILE.PREFIX$ = "" OR (LOCAL.USER AND SYSOP) THEN _ 'KG121802
EXIT SUB
X$ = " " + ERRMES$
13663 EC = 0
FIELD 4, 64 AS CALLERS.RECORD$
IF EC > 0 THEN _
CALL QTPUT ("Caller's file: error"+STR$(EC),1) : _
EC = 0 : _
EXIT SUB
ON EXT.LOG GOTO 13665,13670
'
' **** EXTENDED LOGGING ENTRY ****
'
13665 IF NOT EXTENDED.LOGGING THEN _
EXIT SUB
SUBROUTINE.PARAMETER = 2
CALL AMORPM
X$ = X$ + " at " + TIM$
'
' **** UPDATE CALLERS FILE WITH USER ACTIVITY **** *
'
13670 LSET CALLERS.RECORD$ = X$
CALL PRINTIT (CALLERS.RECORD$)
IF LOCAL.USER AND PRINTER THEN _
EXIT SUB
CALLERS.FILE.INDEX! = CALLERS.FILE.INDEX! + 1
13672 PUT 4,CALLERS.FILE.INDEX! 'KG102502
END SUB
' $SUBTITLE: 'PRINTIT - subroutine to print on the local PC's printer'
' $PAGE
'
' SUBROUTINE NAME -- PRINTIT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ STRING TO WRITE TO THE PRINTER
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- TO WRITE TO THE PRINTER ATTACHED TO THE PC RUNNING
' RBBS-PC AND TOGGLE THE PRINTER SWTICH OFF WHENEVER
' THE PRINTER IS/BECOMES UNAVAILABLE
'
SUB PRINTIT (STRNG$) STATIC
ON ERROR GOTO 65000
13674 IF PRINTER THEN _
LPRINT STRNG$
END SUB
' $SUBTITLE: 'CHANGEDIR - subroutine to change subdirectories'
' $PAGE
'
' SUBROUTINE NAME -- CHANGEDIR
'
' INPUT PARAMETERS -- PARAMETER MEANING
' DIRECTORY$ NAME OF SUBDIRECTORY
'
' OUTPUT PARAMETERS -- OK TRUE IF CHDIR SUCCESSFUL
' EC ERROR CODE
'
' SUBROUTINE PURPOSE -- CHANGE SUBDIRECTORY
'
SUB CHANGEDIR (DIRECTORY$) STATIC
ON ERROR GOTO 65000
EC = 0
OK = TRUE
20103 CHDIR DIRECTORY$
END SUB
' $SUBTITLE: 'FINDIT - subroutine to find if a file exists'
' $PAGE
'
' SUBROUTINE NAME -- FINDIT
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILNAME$ NAME OF FILE TO FIND
'
' OUTPUT PARAMETERS -- OK TRUE IF FILE EXISTS
' EC ERROR CODE
'
' SUBROUTINE PURPOSE -- DETERMINE IF A FILE EXISTS BY RENAMING IT TO ITSELF
'
SUB FINDIT (FILNAME$) STATIC
ON ERROR GOTO 65000
EC = 0
OK = FALSE
IF LEN(FILNAME$) < 1 THEN _
EXIT SUB
IF TURBO.RBBS THEN _
CALL FINDFILE (FILNAME$,OK) : _
IF OK THEN _
GOTO 20222 _
ELSE EXIT SUB
20221 CALL BADFILECHAR (FILNAME$,OK)
IF NOT OK THEN _
EXIT SUB
OK = FALSE
NAME FILNAME$ AS FILNAME$
IF EC = 53 THEN _
EXIT SUB
20222 CLOSE 2
20223 CALL OPENWORK (FILNAME$) ' KG102207
IF EC = 64 OR EC = 76 THEN _
EXIT SUB
OK = TRUE
END SUB
' $SUBTITLE: 'FLUSHCOM -- subroutine reads all char. from comm. port'
' $PAGE
'
' SUBROUTINE NAME -- FLUSHCOM
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STNG$ STRING TO READ CHARACTERS INTO FROM
' THE COMMUNICATIONS PORT (FILE #3)
'
' OUTPUT PARAMETERS -- STNG$
'
' SUBROUTINE PURPOSE -- READS ALL CHARACTER FROM FROM THE COMMUNICATIONS PORT.
'
SUB FLUSHCOM (STRNG$) STATIC
ON ERROR GOTO 65000
IF LOCAL.USER THEN _
EXIT SUB
STRNG$ = ""
IF NOT FOSSIL THEN _
GOTO 20311
20310 CALL FOSREADAHEAD(COMPORT%,CHAR%)
IF CHAR% <> -1 THEN _
CALL FOSRXCHAR(COMPORT%,CHAR%) : _
STRNG$ = STRNG$ + CHR$(CHAR%) : _
GOTO 20310
EXIT SUB
20311 STRNG$ = INPUT$(LOC(3),3) ' FLUSH THE COMM BUFFER
20312 IF EC = 57 THEN _
LINE.STATUS = INP(LINE.STATUS.REGISTER) : _
EC = 0 : _
GOTO 20311
END SUB
' $SUBTITLE: 'NETBIOS - subroutine to lock/unlock using NETBIOS'
' $PAGE
'
' SUBROUTINE NAME -- NETBIOS (WRITTEN BY DOUG AZZARITO)
'
' INPUT PARAMETERS -- IBM.LOCK.CMD = 1-LOCK, 0-UNLOCK
' IBM.FILE.LOCK = 5 USERS FILE
' = 6 SEMAPHORE FILE
' IBM.RECORD.LOCK = RECORD NUMBER TO LOCK
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- LOCK AND UNLOCK FILES USING NETBIOS CMNDS.
' IF LOCK FAILS, THIS ROUTINE TRIES FOREVER.
'
SUB NETBIOS (IBM.LOCK.CMD,IBM.FILE.LOCK,IBM.RECORD.LOCK) STATIC
29900 ON IBM.LOCK.CMD + 1 GOTO 29920, 29910
EXIT SUB
'
' ***** LOCK LOOP *****
'
29910 EC = 0
IF IBM.FILE.LOCK = 6 AND IBM.RECORD.LOCK = 3 THEN _
IBMCOUNT = IBMCOUNT + 1 : _
IF IBMCOUNT > 1 THEN _
EXIT SUB
LOCK IBM.FILE.LOCK, IBM.RECORD.LOCK TO IBM.RECORD.LOCK
IF EC <> 0 THEN _
GOTO 29910
EXIT SUB
29920 EC = 0
IF IBM.FILE.LOCK = 6 AND IBM.RECORD.LOCK = 3 THEN _
IBMCOUNT = IBMCOUNT - 1 : _
IF IBMCOUNT > 0 THEN _
EXIT SUB _
ELSE IBMCOUNT = 0
UNLOCK IBM.FILE.LOCK, IBM.RECORD.LOCK TO IBM.RECORD.LOCK
IF EC <> 0 THEN _
GOTO 29920
END SUB
' $SUBTITLE: 'UPDATEC - update of callers log on exiting'
' $PAGE
'
' SUBROUTINE NAME -- UPDATEC
'
' INPUT PARAMETERS -- PARAMETER MEANING
' CALLERS.FILE.INDEX!
' FIRST.NAME$
' HHH
' LAST.NAME$
' MMM
' NG$
' SSS
' SYSOP.FIRST.NAME$
' SYSOP.LAST.NAME$
'
' OUTPUT PARAMETERS -- CALLERS.RECORD$
' CALLERS.FILE.INDEX!
' SYSOP
'
' SUBROUTINE PURPOSE -- UPDATE THE CALLERS FILE AT LOGOFF SO THAT THE NUMBER
' OF HOURS, MINUTES, AND SECONDS FOR THE SESSION ARE
' RECORDED AS THE LAST 9 CHARACTERS OF THE 64-CHARACTER
' CALLERS FILE RECORD
'
SUB UPDATEC STATIC
ON ERROR GOTO 65000
IF CALLERS.FILE.PREFIX$ = "" THEN _ 'KG102705
EXIT SUB
'
' **** UPDATE CALLERS FILE AT LOGOFF ****
'
43050 FIELD 4,55 AS CALLERS.RECORD$,3 AS HOURS$,3 AS MINUTES$,3 AS SECONDS$
LSET CALLERS.RECORD$ = MID$(NG$,65,55)
LSET HOURS$ = STR$(HHH)
LSET MINUTES$ = STR$(MMM)
LSET SECONDS$ = STR$(SSS)
CALLERS.FILE.INDEX! = CALLERS.FILE.INDEX! + 1
PUT 4,CALLERS.FILE.INDEX!
FIELD 4,64 AS CALLERS.RECORD$
LSET CALLERS.RECORD$ = LEFT$(NG$,64)
CALLERS.FILE.INDEX! = CALLERS.FILE.INDEX! + 1
PUT 4,CALLERS.FILE.INDEX!
43060 LSET CALLERS.RECORD$ = STRING$(64,CHR$(0))
CALLERS.FILE.INDEX! = CALLERS.FILE.INDEX! + 1
PUT 4,CALLERS.FILE.INDEX!
CALLERS.FILE.INDEX! = CALLERS.FILE.INDEX! + 1
PUT 4,CALLERS.FILE.INDEX!
IF ORIG.CALLERS$ <> CALLERS.FILE$ THEN _
CALLERS.FILE$ = ORIG.CALLERS$ : _
CALL SETCALL : _
GOTO 43050
END SUB
' $SUBTITLE: 'FINDFREE - subroutine to find space on a device'
' $PAGE
'
' SUBROUTINE NAME -- FINDFREE
'
' INPUT PARAMETERS -- PARAMETER MEANING
' Z$ NAME OF FILE TO FIND
'
' OUTPUT PARAMETERS -- FREE.SPACE$ NUMBER OF BYTES FREE
'
' SUBROUTINE PURPOSE -- TO DETERMINE AMOUNT OF FREE SPACE ON A DEVICE
'
SUB FINDFREE STATIC
ON ERROR GOTO 65000
EC = 0
52000 IF TURBO.RBBS THEN _
GOTO 52003
FREE.SPACE$ = ""
CLS
EC = 0
52001 FILES Z$
IF EC = 53 AND (Z$ = COMMENTS.FILE$ OR Z$ = UPLOAD.DRIVE.FILE$ ) THEN _
CALL OPENOUTW (Z$) : _
GOTO 52000
IF EC = 53 AND Z$ = UPLOAD.DIRECTORY$ THEN _
A$ = "Upload directory missing. Tell SYSOP" : _
SUBROUTINE.PARAMETER = 6 : _
CALL TPUT : _
GOTO 52002
FOR X = 1 TO 25
FREE.SPACE$ = FREE.SPACE$ + CHR$(SCREEN (3,X))
NEXT
52002 SUBROUTINE.PARAMETER = 1
CALL LINE25
EXIT SUB
52003 AX% = 0
BX% = 0
CX% = 0
DX% = 0
IF MID$(Z$,2,1) = ":" THEN _
AX% = ASC(Z$) - ASC("A") + 1
CALL RBBSFREE (AX%,BX%,CX%,DX%)
I# = CDBL(AX%) * BX%
I# = I# * CX%
FREE.SPACE$ = STR$(I#) + _
" bytes free"
END SUB
' $SUBTITLE: 'OPENWORK - subroutine to open RBBS-PC's work file (2)'
' $PAGE
'
' SUBROUTINE NAME -- OPENWORK
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILE.NAME$ NAME OF FILE TO FIND
' SHARE.IT USE DOS' "SHARE" FACILITIES
'
' OUTPUT PARAMETERS -- EC ERROR CODE
'
' SUBROUTINE PURPOSE -- TO OPEN RBBS-PC'S "WORK" FILE (NUMBER 2)
'
SUB OPENWORK (FILNAME$) STATIC
ON ERROR GOTO 65000
58000 CLOSE 2
58010 EC = 0
58020 IF SHARE.IT THEN _
OPEN FILNAME$ FOR INPUT SHARED AS #2 _
ELSE OPEN "I",2,FILNAME$
IF EC = 52 THEN _
GOTO 58010
58030 END SUB
' $SUBTITLE: 'OPENFMS - subroutine to open the FMS directory'
' $PAGE
'
' SUBROUTINE NAME -- OPENFMS
'
' INPUT PARAMETERS -- PARAMETER MEANING
' SHARE.IT DOS SHARING FLAG
' FMS.DIRECTORY$ NAME OF FMS DIRECTORY
'
' OUTPUT PARAMETERS -- LAST.REC NUMBER OF THE LAST
' RECORD IN THE FILE
'
' SUBROUTINE PURPOSE -- TO OPEN THE UPLOAD DIRECTORY AS A RANDOM FILE AND FIND
' THE NUMBER OF THE LAST RECORD IN THE FILE.
'
SUB OPENFMS (LAST.REC) STATIC
58190 ON ERROR GOTO 65000
FILE.LENGTH = 38 + MAX.DESC.LEN
CLOSE 2
IF ACTIVE.FMS.DIRECTORY$ = "" THEN _
IF MENU.INDEX = 6 THEN _
ACTIVE.FMS.DIRECTORY$ = LIBRARY.DIRECTORY$ _
ELSE ACTIVE.FMS.DIRECTORY$ = FMS.DIRECTORY$
IF SHARE.IT THEN _
OPEN ACTIVE.FMS.DIRECTORY$ FOR RANDOM SHARED AS #2 LEN=FILE.LENGTH _
ELSE OPEN "R",2,ACTIVE.FMS.DIRECTORY$,FILE.LENGTH
'IF EC > 0 THEN _
' CALL QTPUT ("Drive/path does not exist or bad name for FMS dir " + _
' ACTIVE.FMS.DIRECTORY$,1) : _
' END
IF EC > 0 THEN
EC = 0
CALL QTPUT (CHR$(7)+"Error Has Occured...try again !!!!! " ,1)
LAST.REC =0
EXIT SUB
END IF
LAST.REC = LOF(2)/FILE.LENGTH
IF ACTIVE.FMS.DIRECTORY$ = PREV.FMS$ THEN _
EXIT SUB
PREV.FMS$ = ACTIVE.FMS.DIRECTORY$
FIELD 2, FILE.LENGTH AS FMS.REC$
GET #2,1
A = (LEFT$(FMS.REC$,4) <> "\FMS")
UPINC = 2*(INSTR(FMS.REC$," TOP ") = 0 OR A) + 1
DATE.ORDERED.FMS = A OR (INSTR(FMS.REC$," NOSORT") = 0)
END SUB
' $SUBTITLE: 'OPENOUTW - subroutine to open output work file (2)'
' $PAGE
'
' SUBROUTINE NAME -- OPENOUTW
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILE.NAME$ NAME OF FILE TO FIND
' SHARE.IT USE DOS' "SHARE" FACILITIES
'
' OUTPUT PARAMETERS -- EC ERROR CODE
'
' SUBROUTINE PURPOSE -- TO OPEN RBBS-PC'S "WORK" FILE (NUMBER 2) FOR OUTPUT
'
SUB OPENOUTW (FILNAME$) STATIC
ON ERROR GOTO 65000
58220 CLOSE 2
58225 EC = 0
58230 IF SHARE.IT THEN _
OPEN FILNAME$ FOR OUTPUT SHARED AS #2 _
ELSE OPEN "O",2,FILNAME$
58235 END SUB
' $SUBTITLE: 'KILLWORK - subroutine to delete a "work" file'
' $PAGE
'
' SUBROUTINE NAME -- KILLWORK
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILNAME$ NAME OF FILE TO DELETE
'
' OUTPUT PARAMETERS -- EC ERROR CODE
'
' SUBROUTINE PURPOSE -- TO DELETE A RBBS-PC "WORK" FILE
'
SUB KILLWORK (FILNAME$) STATIC
ON ERROR GOTO 65000
58260 CLOSE 2
EC = 0
58270 KILL FILNAME$
58275 END SUB
' $SUBTITLE: 'GETPASWD - subroutine to read the "passwords" file'
' $PAGE
'
' SUBROUTINE NAME -- GETPASWD
'
' PARAMETER MEANING
' INPUT PARAMETERS -- FILE # 2 OPENED
'
' OUTPUT PARAMETERS -- TEMP.PASSWORD$
' TEMP.SECURITY.LEVEL
' TEMP.TIME.ALLOWED
' TEMP.REG.PERIOD
' TEMP.MAX.PER.DAY
'
' SUBROUTINE PURPOSE -- TO READ THE RBBS-PC "PASSWORDS" FILE
'
58280 SUB GETPASWD STATIC
ON ERROR GOTO 65000
EC = 0
INPUT #2,TEMP.PASSWORD$, TEMP.SECURITY.LEVEL, _
TEMP.TIME.ALLOWED, TEMP.MAX.PER.DAY, _
TEMP.REG.PERIOD, START.TIME, _
END.TIME, BYTE.METHOD, _
RATIO.RESTRICTION#, INITIAL.CREDIT#, _
TEMP.TIME.LOCK
58285 END SUB
' $SUBTITLE: 'READDIR - subroutine to read the "DIR" files'
' $PAGE
'
' SUBROUTINE NAME -- READDIR
'
' PARAMETER MEANING
' INPUT PARAMETERS -- FILE # 2 OPENED
' WHICH.LINE HOW MANY LINES TO ADVANCE
'
' OUTPUT PARAMETERS -- A$
'
' SUBROUTINE PURPOSE -- TO READ POSSIBLE "DIR" FILES
'
58290 SUB READDIR (WHICH.LINE) STATIC
ON ERROR GOTO 65000
EC = 0
FOR I = 1 TO WHICH.LINE
LINE INPUT #2,A$
NEXT
58295 END SUB
' $SUBTITLE: 'READPARMS - subroutine to read parameter values'
' $PAGE
'
' SUBROUTINE NAME -- READPARMS
'
' PARAMETER MEANING
' INPUT PARAMETERS -- FILE # 2 OPENED
' NUM.PARMS # parameters to read
' WHICH.LINE Which set of parms to return
' OUTPUT PARAMETERS -- ARA.TO.USER$ Array of string values
' FILE.SECURITY
' FILE.PASSWORD$
'
' SUBROUTINE PURPOSE -- To read different values, where values are
' separated by a comma or carriage-return-line-feed.
'
58300 SUB READPARMS (ARA.TO.USE$(1),NUM.PARMS,WHICH.LINE) STATIC
ON ERROR GOTO 65000
EC = 0
FOR J = 1 TO WHICH.LINE
FOR I = 1 TO NUM.PARMS
INPUT #2,ARA.TO.USE$(I)
NEXT
NEXT
58305 END SUB
' $SUBTITLE: 'READANY - subroutine to read file 2 into A$'
' $PAGE
'
' SUBROUTINE NAME -- READANY
'
' PARAMETER MEANING
' INPUT PARAMETERS -- FILE # 2 OPENED
'
' OUTPUT PARAMETERS -- A$
'
' SUBROUTINE PURPOSE -- TO READ FILE #2 INTO A$
'
58310 SUB READANY STATIC
ON ERROR GOTO 65000
EC = 0
INPUT #2,A$
58315 END SUB
' $SUBTITLE: 'PRINTWRK - subroutine to print to file 2'
' $PAGE
'
' SUBROUTINE NAME -- PRINTWRK
'
' PARAMETER MEANING
' INPUT PARAMETERS -- FILE # 2 OPENED
' STRING TO WRITE OUT
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- TO PRINT A STRING TO FILE #2
'
58320 SUB PRINTWRK (STRNG$) STATIC
ON ERROR GOTO 65000
EC = 0
PRINT #2,STRNG$;
58325 END SUB
' $SUBTITLE: 'GETWORK - subroutine to read file 2'
' $PAGE
'
' SUBROUTINE NAME -- GETWORK
'
' PARAMETER MEANING
' INPUT PARAMETERS -- REC.LEN Length of record
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- TO READ A RECORD FROM FILE #2
'
58330 SUB GETWORK (REC.LEN) STATIC
ON ERROR GOTO 65000
EC = 0
FIELD 2, REC.LEN AS DOWNLOAD.RECORD$
GET 2,(LOC(2)+1)
58335 END SUB
' $SUBTITLE: 'OPENWRKA - subroutine to open output work file (2)'
' $PAGE
'
' SUBROUTINE NAME -- OPENWRKA
'
' INPUT PARAMETERS -- PARAMETER MEANING
' FILNAME$ NAME OF FILE TO FIND
' SHARE.IT USE DOS' "SHARE" FACILITIES
'
' OUTPUT PARAMETERS -- EC ERROR CODE
'
' SUBROUTINE PURPOSE -- TO OPEN RBBS-PC'S "WORK" FILE (NUMBER 2) FOR APPENDED
' OUTPUT
'
58340 SUB OPENWRKA (FILNAME$) STATIC
ON ERROR GOTO 65000
CLOSE 2
EC = 0
IF SHARE.IT THEN _
OPEN FILNAME$ FOR APPEND SHARED AS #2 _
ELSE OPEN "A",2,FILNAME$
58345 END SUB
' $SUBTITLE: 'PRNTWRKA - subroutine to print to file 2 with CR'
' $PAGE
'
' SUBROUTINE NAME -- PRNTWRKA
'
' PARAMETER MEANING
' INPUT PARAMETERS -- FILE # 2 OPENED
' STRING TO WRITE OUT
'
' OUTPUT PARAMETERS -- NONE
'
' SUBROUTINE PURPOSE -- TO PRINT A STRING TO FILE #2 FOLLOWED BY A CARRIAGE
' RETURN
'
58350 SUB PRNTWRKA (STRNG$) STATIC
ON ERROR GOTO 65000
EC = 0
PRINT #2,STRNG$
58355 END SUB
' $SUBTITLE: 'CHECKINT - subroutine to check input is an integer'
' $PAGE
'
' SUBROUTINE NAME -- CHECKINT
'
' PARAMETER MEANING
' INPUT PARAMETERS -- STRNG$ STRING TO VERIFY CAN BE AN INTEGER
'
' OUTPUT PARAMETERS -- EC = 0 MEANS IT IS AN INTEGER VALUE
' <> 0 MEANS IT IS NOT AN INTEGER VALUE
'
' SUBROUTINE PURPOSE -- TO PRINT VALIDATE A STRING CAN HAVE AN INTEGER VALUE
'
58360 SUB CHECKINT (STRNG$) STATIC
ON ERROR GOTO 65000
EC = 0
TESTED.INTEGER.VALUE = VAL(STRNG$)
58365 END SUB
' $SUBTITLE: 'PUTCOM -- subroutine to write to communications port'
' $PAGE
'
' SUBROUTINE NAME -- PUTCOM
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STNG$ STRING TO PRINT TO COMM PORT
' FLOW.CONTROL WHETHER USING CLEAR TO SEND FOR FLOW
' CONTROL BETWEEN THE PC AND THE MODEM
'
' OUTPUT PARAMETERS --
'
' SUBROUTINE PURPOSE -- CHECKS FOR CARRIER DROP AND FLOW CONTROL (I.E. "CLEAR
' TO SEND" SIGNAL) BEFORE WRITING TO THE COMMUNICATIONS
' PORT.
'
59650 SUB PUTCOM (STRNG$) STATIC
ON ERROR GOTO 65000
IF LOCAL.USER THEN _
EXIT SUB
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB
IF NOT XOFF.ED THEN _
GOTO 59652
SUBROUTINE.PARAMETER = 1
CALL LINE25
Y$ = XOFF$
CALL SETABORT (X!,WAIT.BEFORE.DISCONNECT)
WHILE Y$ = XOFF$ AND SUBROUTINE.PARAMETER <> -1
CHAR% = -1
WHILE CHAR% = -1 AND SUBROUTINE.PARAMETER <> -1
GOSUB 59654
WEND
IF CHAR% <> -1 THEN _
CALL GETCOM(Y$) : _
IF XON.XOFF AND Y$ <> XON$ THEN _
Y$ = XOFF$
WEND
XOFF.ED = FALSE
SUBROUTINE.PARAMETER = 1
CALL LINE25
59652 NOT.CTS = FALSE
IF NOT FOSSIL THEN _
PRINT #3,STRNG$; : _
EXIT SUB
IF STRNG$ = "" THEN _
EXIT SUB
FOR N = 1 TO LEN(STRNG$)
CHAR% = ASC(MID$(STRNG$,N,1))
59653 CALL FOSTXCHARNW(COMPORT%,CHAR%,RESULT%)
IF RESULT% = 0 THEN _
GOTO 59653
NEXT
EXIT SUB
59654 CALL EOFCOMM (CHAR%)
CALL GOIDLE
CALL CARRIER
CALL CHKTREMAIN (X!)
RETURN
END SUB
' $SUBTITLE: 'PUTWORK -- subroutine to write to upload files'
' $PAGE
'
' SUBROUTINE NAME -- PUTWORK
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STNG$ STRING TO WRITE TO FILE
' REC.NUM RECORD NUMBER TO WRITE
' REC.LEN LENGTH OF RECORD TO WRITE
'
' OUTPUT PARAMETERS --
'
' SUBROUTINE PURPOSE -- WRITES UPLOADED FILE RECORDS TO WORK FILE
'
59660 SUB PUTWORK (STRNG$,REC.NUM,REC.LEN) STATIC
ON ERROR GOTO 65000
FIELD #2,REC.LEN AS UPLOAD.RECORD$
LSET UPLOAD.RECORD$ = STRNG$
REC.NUM = REC.NUM + 1
PUT #2,REC.NUM
END SUB
'
' $SUBTITLE: 'DGSALIAS - Subroutine to Create/Update Alias Info file'
' $PAGE
'
' SUBROUTINE NAME -- DGSALIAS
'
' INPUT PARAMETERS -- PARAMETER MEANING
' GRN$ CONFERENCE NAME
' ORIG.USER.NAME$ USERS - LOG ON NAME
' DGS.ALIAS$ USERS - ALIAS NAME
' DGS.STL$ NULL FIRST TIME IN
' 'STILL' IF ALIAS EXISTS
' OR REAL NAME
' DGS.FILE.NAME$ CONFERENCE ALIAS FILE
'
' OUTPUT PARAMETERS -- GRN$ ORIG.USER.NAME$ DGS.ALIAS$ DGS.STL$
' DGS.FILE.NAME$
'
' SUBROUTINE PURPOSE -- TO READ CONFA.DEF AND GET USERS ALIAS OR
' CREATE ONE
'
SUB DGSALIAS (GRN$,ORIG.USER.NAME$,DGS.ALIAS$,DGS.STL$,DGS.FILE.NAME$) STATIC
'
IF DGS.STL$ = "" THEN
CONFA.DEF.FLAG = 0
CALL BRKFNAME (MAIN.USER.FILE$,DRV$,PREFIX$,EXT$,TRUE)
DGS.FILE.NAME$ = DRV$ + GRN$ + "A.DEF"
CALL FINDIT (DGS.FILE.NAME$)
IF OK THEN
CONFA.DEF.FLAG = TRUE
END IF
IF CONFA.DEF.FLAG = TRUE THEN
OPEN "I", 7, DGS.FILE.NAME$
DGS.ALIAS$ = ""
WHILE DGS.ALIAS$ = "" AND NOT EOF(7)
INPUT #7, DGS.USER.NAME$, DGS.TEMP.ALIAS$
DGS.UNL = LEN(DGS.USER.NAME$)
IF DGS.USER.NAME$ = LEFT$(ORIG.USER.NAME$,DGS.UNL) THEN
DGS.ALIAS$ = DGS.TEMP.ALIAS$
END IF
WEND
CLOSE 7
ELSE
DGS.ALIAS$ = "NO CONFA.DEF"
EXIT SUB
END IF
END IF
CALL GOODALS (GRN$,ORIG.USER.NAME$,DGS.ALIAS$,DGS.STL$,DGS.FILE.NAME$)
END SUB
'
'
' $SUBTITLE: 'GOODALS - Subroutine to Make Sure Alias Good'
' $PAGE
'
' SUBROUTINE NAME -- GOODALS
'
' INPUT PARAMETERS -- PARAMETER MEANING
' GRN$ CONFERENCE NAME
' ORIG.USER.NAME$ USERS - LOG ON NAME
' DGS.ALIAS$ USERS - ALIAS NAME
' DGS.STL$ NULL FIRST TIME IN
' 'STILL' IF ALIAS EXISTS
' OR REAL NAME
' DGS.FILE.NAME$ CONFERENCE ALIAS FILE
'
' OUTPUT PARAMETERS -- GRN$ ORIG.USER.NAME$ DGS.ALIAS$ DGS.STL$
' DGS.FILE.NAME$
'
' SUBROUTINE PURPOSE -- TO READ CONFA.DEF AND SEE IF GET USERS ALIAS IS
' ALREADY IN USE OR A REAL NAME
'
SUB GOODALS (GRN$,ORIG.USER.NAME$,DGS.ALIAS$,DGS.STL$,DGS.FILE.NAME$) STATIC
'
IF DGS.ALIAS$ = "" THEN
DGS.SFN.SLN$ = SYSOP.FIRST.NAME$+" "+SYSOP.LAST.NAME$
A$ = "Do you" +DGS.STL$+ " want to use an Alias? (Y,[N])"
SUBROUTINE.PARAMETER = 1
CALL TGET
IF YES THEN
ABFLG$ = ""
A$ = "Enter Alias (31 Char. Max.) "
SUBROUTINE.PARAMETER = 1
CALL TGET
CALL ALLCAPS (B$)
IF B$ = "" OR INSTR(SPACE$(31),B$) > 0 THEN
B$ = ""
ABFLG$ = "Alias Must NOT be Blank"
END IF
IF LEN(B$) > 31 THEN
B$= ""
ABFLG$ = "Length Must NOT Exceed 31 Characters"
END IF
IF B$ = "SYSOP" OR B$ = DGS.SFN.SLN$ THEN
A$ = CHR$(7)+CHR$(7)
A$ = A$ + "Wrong Answer! Alias Request Denied!"
A$ = A$ + CHR$(13) + "Contact Sysop for Alias Retry"
CALL QTPUT (A$,2)
DGS.ALIAS$ = ORIG.USER.NAME$+CHR$(250)
ACTIVE.USER.NAME$ = ORIG.USER.NAME$+CHR$(250)
FIRST.NAME$ = ORIG.USER.NAME$+CHR$(250)
ELSE
OPEN "I", 7, DGS.FILE.NAME$
WHILE ABFLG$ = "" AND NOT EOF(7)
INPUT #7, DGS.USER.NAME$, DGS.TEMP.ALIAS$
IF B$ = DGS.USER.NAME$ THEN
ABFLG$ = " is a Real User"
ELSE
IF B$ = DGS.TEMP.ALIAS$ THEN
ABFLG$ = " has Already been Used"
END IF
END IF
WEND
CLOSE 7
IF ABFLG$="" THEN
DGS.ALIAS$ = B$
ACTIVE.USER.NAME$ = B$
FIRST.NAME$ = B$
ELSE
A$="Sorry "+FIRST.NAME$+" but "+B$+ABFLG$
CALL QTPUT (A$,1)
DGS.STL$ = " still"
DGS.ALIAS$ = ""
END IF
END IF
ELSE
DGS.ALIAS$ = ORIG.USER.NAME$
END IF
IF DGS.ALIAS$ <> "" THEN
CLOSE 2
OPEN "A", 2, DGS.FILE.NAME$
WRITE #2, ORIG.USER.NAME$, DGS.ALIAS$
CLOSE 2
END IF
ELSE
ACTIVE.USER.NAME$ = DGS.ALIAS$
FIRST.NAME$ = DGS.ALIAS$
END IF
END SUB
'
'********************************************************************
' THREAD1 First message thread routine *
' THREAD2 Second message thread routine *
' THREAD3 Third message thread routine *
'********************************************************************
'===========================================================================
' $SUBTITLE: 'THREAD1 - create/update threaded message file'
' $PAGE
'
' SUBROUTINE NAME -- THREAD1
'
' INPUT PARAMETERS -- PARAMETER MEANING
' HIGH.MESSAGE.NUMBER This reply's message number
' CURRENT.MESSAGE Message number being replied
'
' OUTPUT PARAMETERS -- <<NONE>>
'
' SUBROUTINE PURPOSE -- SUBROUTINE TO...
'
SUB THREAD1 (HIGH.MESSAGE.NUMBER,CURRENT.MESSAGE,GRN$) STATIC
IF INSTR(GRN$," ") = 0 THEN 'PE102587
FILE.NAME$ = GRN$ + "T" 'PE102587
ELSE
FILE.NAME$ = LEFT$(GRN$,INSTR(GRN$," ")-1)+"T" 'PE102587
END IF
CURRENT.MESSAGE$ = STR$(CURRENT.MESSAGE)
HIGH.MESSAGE.NUMBER$ = STR$(HIGH.MESSAGE.NUMBER)
OPEN "R",9,FILE.NAME$,12
FIELD 9, 6 AS CM$, 6 AS HMN$
LSET CM$ = CURRENT.MESSAGE$
LSET HMN$ = HIGH.MESSAGE.NUMBER$
PUT #9,INT(LOF(9)/12)+1
CLOSE (9)
59670 END SUB ' THREAD1
'
' $SUBTITLE: 'THREAD2 - a message was killed - check threaded message file'
' $PAGE
'
' SUBROUTINE NAME -- THREAD2
'
' INPUT PARAMETERS -- PARAMETER MEANING
' MESSAGE.TO.KILL Killed message's number
'
' OUTPUT PARAMETERS -- <<NONE>>
'
' SUBROUTINE PURPOSE -- SUBROUTINE TO ...
'
SUB THREAD2 (MESSAGE.TO.KILL,ACTIVE.MESSAGES,GRN$) STATIC
IF INSTR(GRN$," ") = 0 THEN 'PE102587
FILE.NAME$ = GRN$ + "T"
ELSE
FILE.NAME$ = LEFT$(GRN$,INSTR(GRN$," ")-1)+"T"
END IF
OPEN "R",9,FILE.NAME$,12
FIELD 9, 6 AS CM$, 6 AS HMN$
FOR I = 1 TO INT(LOF(9)/12)
GET 9,I
IF VAL(CM$) = MESSAGE.TO.KILL THEN ' MARK THE RECORD
LSET CM$ = LEFT$(CM$,5) + "K"
PUT 9,I
ELSE
IF VAL(HMN$) = MESSAGE.TO.KILL THEN ' MARK THE RECORD
LSET HMN$ = LEFT$(HMN$,5) + "K"
LSET CM$ = LEFT$(CM$,5) + "K"
PUT 9,I
END IF
END IF
NEXT I
CLOSE (9)
59680 END SUB ' THREAD2
'
' $SUBTITLE: 'THREAD3 - a message was killed - check threaded message file'
' $PAGE
'
' SUBROUTINE NAME -- THREAD3
'
' INPUT PARAMETERS -- PARAMETER MEANING
' CURRENT.MESSAGE Message's number
'
' OUTPUT PARAMETERS -- <<NONE>>
'
' SUBROUTINE PURPOSE -- SUBROUTINE TO ...
'
SUB THREAD3 (CURRENT.MESSAGE,GRN$) STATIC
IF JUST.SEARCHING THEN _ 'PE 01/16/89
EXIT SUB 'PE 01/16/89
IF INSTR(GRN$," ") = 0 THEN
FILE.NAME$ = GRN$ + "T"
ELSE
FILE.NAME$ = LEFT$(GRN$,INSTR(GRN$," ")-1)+"T"
END IF
OPEN "R",9,FILE.NAME$,12
FIELD 9, 6 AS CM$, 6 AS HMN$
AA$ = ""
ZZ$ = ""
FOR I = 1 TO INT(LOF(9)/12)
GET 9,I
IF RIGHT$(HMN$,1) = "K" THEN 59690
IF VAL(CM$) = CURRENT.MESSAGE AND RIGHT$(HMN$,1) <> "K" THEN
AA$ = AA$ + HMN$
END IF
IF VAL(HMN$) = CURRENT.MESSAGE AND RIGHT$(CM$,1) = "K" THEN
ZZ$ = LEFT$(CM$,5) + CX$(1)+"(deleted) "+EMPHASIZE.OFF$
END IF
IF VAL(HMN$) = CURRENT.MESSAGE AND RIGHT$(CM$,1) <> "K" THEN
ZZ$ = CM$
END IF
59690 NEXT I
IF LEN(AA$) > 0 THEN
CALL QTPUT(FG.3$+" Reply(ies) in message number(s): "+CX$(4) + AA$+EMPHASIZE.OFF$,1)
END IF
IF LEN(ZZ$) > 0 THEN
CALL QTPUT (FG.4$+" This message is in reply to message " +FG.1$+ ZZ$+EMPHASIZE.OFF$,1)
END IF
CALL QTPUT (CX$(1)+ "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"+EMPHASIZE.OFF$,1)
CLOSE (9)
59695 END SUB ' THREAD3
'
' $SUBTITLE: 'THREAD4 - UPDATE CONFR.DEF FILE FOR MESSAGE RECOVERY'
' $PAGE
'
' SUBROUTINE NAME -- THREAD4
'
' INPUT PARAMETERS -- PARAMETER MEANING
'
' MESSAGE.TO.RECOVER MESSAGE NUMBER BEING RECOVERED
' FIRST.MESSAGE.RECORD NOT USED HERE BUT PASSED IN
' FROM RBBS CALL TO SUB2
' ACTION.FLAG PASSED FROM SUB2 NEEDED TO
' GIVE BACK TO RBBS MAIN CODE
' GRN$ CONFERENCE NAME
'
' OUTPUT PARAMETERS -- <<NONE>>
'
' SUBROUTINE PURPOSE -- SUBROUTINE - UPDATE CONFR.DEF FILE AFTER MSG RECVRY
'
SUB THREAD4 (MESSAGE.TO.RECOVER,FIRST.MESSAGES.RECORD,ACTION.FLAG,GRN$) STATIC
IF INSTR(GRN$," ") = 0 THEN
FILE.NAME$ = GRN$ + "T"
ELSE
FILE.NAME$ = LEFT$(GRN$,INSTR(GRN$," ")-1)+"T"
END IF
OPEN "R",9,FILE.NAME$,12 'WILL CREATE FILE IF NOT EXIST
FIELD 9, 6 AS CM$, 6 AS HMN$
FOR I = 1 TO INT(LOF(9)/12)
GET 9,I
IF VAL(CM$) = MESSAGE.TO.RECOVER THEN
LSET CM$ = LEFT$(CM$,5) + " "
PUT 9,I
ELSE
IF VAL(HMN$) = MESSAGE.TO.RECOVER THEN
LSET HMN$ = LEFT$(HMN$,5) + " "
LSET CM$ = LEFT$(CM$,5) + " "
PUT 9,I
END IF
END IF
NEXT I
CLOSE (9)
59698 END SUB 'THREAD4
'
' $SUBTITLE: 'VIEWTXT - Subroutine to display ASCII file from ARC file'
' $PAGE
'
SUB VIEWTXT STATIC
ON ERROR GOTO 65000
'
60140 SUBROUTINE.PARAMETER = 1
A$ ="T)ype, X)tract, C)ompress, D)ir, H)elp or [Quit]" +CRLF$
A$ = CRLF$ + A$ + "Enter Choice T,X,C,D,?,H,[Q] "
TURBO.KEY = -TURBO.KEY.USER
CALL TGET
IF SUBROUTINE.PARAMETER = -1 THEN_
EXIT SUB
IF Q = 0 THEN _
EXIT SUB 'Pe 05/24/89
CALL ALLCAPS (B$)
X = INSTR("TXCD?HQ",B$)
ON X GOTO 60149,60168,60175,60142,60141,60141,60180
GOTO 60180
'
60141 CALL BUFFILE (HELP.PATH$ + "ZIP" + HELP.EXTENSION$,X) 'Pe 03/26/89
GOTO 60140 'Pe 03/26/89
60142 CALL QTPUT ("Creating file list, one moment please....",1)
EXTRACT$ = "DIR "+ ARKVIEW.PATH$+">VUZIP"+NODE.ID$+".LST"
SHELL EXTRACT$
CALL BUFFILE("VUZIP"+NODE.ID$ +".LST",X)
GOTO 60140
'
60149 SUBROUTINE.PARAMETER = 1
A$ = "What file(s) to Type, R)elist or [ENTER] to quit" 'DMOD1
CALL TGET
IF SUBROUTINE.PARAMETER = -1 THEN _
EXIT SUB 'Pe 05/24/89
B = 1 'DMOD1
IF Q = 0 THEN _ 'DMOD1
GOTO 60140 'Pe 05/24/89 was Exit Sub
IF B$ = "R" or B$ = "r" THEN _
CALL BUFFILE (ARC.WORK$,X) : _
GOTO 60149
LAST.ARC = Q 'DMOD1
FIRST.ARC = B 'DMOD1
FOR ARC.INDEX = FIRST.ARC TO LAST.ARC 'DMOD1
Z$ = B$(ARC.INDEX) 'DMOD1
CALL ALLCAPS (Z$)
IF INSTR(Z$,"*") OR INSTR(Z$,"?") THEN _
CALL QTPUT ("Sorry Widcars NOT allowed !!",1) : _
GOTO 60149 'PEMOD1
CALL BRKFNAME (Z$,DRV$,PREFIX$,EXT$,FALSE) 'DMOD1
IF EXT$ = "ARC" OR EXT$ = "COM" OR EXT$ = "EXE" OR EXT$ = "BAS" OR _ 'DMOD1
EXT$ = "BIN" OR EXT$ = "LIB" OR EXT$ = "OBJ" OR EXT$ = "PIC" THEN _
CALL QTPUT ("Sorry, only ASCII files can be viewed",1) :_ 'DMOD1
GOTO 60149 'DMOD1
CALL QTPUT ("Please stand by while I extract that file....",1) 'DMOD1
'
'
' ******* Next 3 lines added for ZIP support Pe 02/19/89
IF LAST.EXT$ = "ZIP" THEN _
SHOWME$ = LIBRARY.ARCHIVE.PATH$+"PKUNZIP -O " + FILE.NAME$ + " " + Z$ + " "+ARKVIEW.PATH$ : _
GOTO 60150
'
IF MID$(LIBRARY.ARCHIVE.PROGRAM$,1,2) ="PK" THEN _
SHOWME$ = LIBRARY.ARCHIVE.PATH$+"PKXARC -R " + FILE.NAME$ + " " + Z$ + " "+ARKVIEW.PATH$
IF MID$(LIBRARY.ARCHIVE.PROGRAM$,1,2) ="AR" THEN _
SHOWME$ = LIBRARY.ARCHIVE.PATH$+"ARCE " + FILE.NAME$ + " " + Z$ + " "+ARKVIEW.PATH$ + " /R"
IF MID$(LIBRARY.ARCHIVE.PROGRAM$,1,3) ="PAK" THEN _
SHOWME$ = LIBRARY.ARCHIVE.PATH$+"PAK /E/WA " + FILE.NAME$ + " "+ ARKVIEW.PATH$+"\"+Z$
60150 SHELL SHOWME$ 'Pe 02/19/89
Z$ = ARKVIEW.PATH$ +"\"+ Z$ 'Added \ to fix error 63
TEMP$ = Z$
'
CALL BUFFILE (Z$,X) 'DMOD1
IF NOT OK THEN _
CALL QTPUT(CHR$(7)+"File NOT found or bad Spelling",1) :_
GOTO 60149
CALL KILLWORK(TEMP$) 'get rid of the files that were xtracted PEMOD1
NEXT 'DMOD1
GOTO 60140
'
60168 SUBROUTINE.PARAMETER = 1
CALL SKIPLINE (1)
60169 A$ = "What file(s) to Extract, R)elist or [ENTER] quits"+CRLF$ + _
"Wildcards ARE supported for this feature " +EMPHASIZE.OFF$
CALL TGET
IF SUBROUTINE.PARAMETER = -1 THEN _ 'Pe 11/29/88
EXIT SUB 'Pe 11/29/88
IF B$ = "R" or B$ = "r" THEN _
CALL BUFFILE (ARC.WORK$,X) : _
GOTO 60168
B = 1 'DMOD1
IF Q = 0 THEN _ 'DMOD1
EXIT SUB 'DMOD1
LAST.ARC = Q 'DMOD1
FIRST.ARC = B 'DMOD1
FOR ARC.INDEX = FIRST.ARC TO LAST.ARC 'DMOD1
Z$ = B$(ARC.INDEX) 'DMOD1
CALL ALLCAPS (Z$)
CALL BRKFNAME (Z$,DRV$,PREFIX$,EXT$,FALSE) 'DMOD1
CALL QTPUT ("Please stand by while I extract the file(s)....",1) 'DMOD1
'
'Next 3 lines for ZIP Support Pe 02/19/89
'
IF LAST.EXT$ = "ZIP" THEN _
SHOWME$ = LIBRARY.ARCHIVE.PATH$+"PKUNZIP -O " + FILE.NAME$ + " " + Z$ + " "+ARKVIEW.PATH$ : _
GOTO 60170
'
'
IF MID$(LIBRARY.ARCHIVE.PROGRAM$,1,2) ="PK" THEN _
SHOWME$ = LIBRARY.ARCHIVE.PATH$+"PKXARC -R " + FILE.NAME$ + " " + Z$ + " " + ARKVIEW.PATH$
IF MID$(LIBRARY.ARCHIVE.PROGRAM$,1,2) ="AR" THEN _
SHOWME$ = LIBRARY.ARCHIVE.PATH$+"ARCE " + FILE.NAME$ + " " + Z$ + " " + ARKVIEW.PATH$+" /R"
IF MID$(LIBRARY.ARCHIVE.PROGRAM$,1,3) ="PAK" THEN _
SHOWME$ = LIBRARY.ARCHIVE.PATH$+"PAK /E/WA " + FILE.NAME$ + " " + ARKVIEW.PATH$ + "\" +Z$
'
60170 SHELL SHOWME$ 'Added line Number Pe 02/19/89
LOOKFOR$ = ARKVIEW.PATH$ + "\" + Z$
CALL FINDIT(LOOKFOR$)
IF NOT OK THEN _
CALL QTPUT ("Error extracting " + Z$ + "...file Skipped...",2) : _
GOTo 60171
CALL QTPUT(Z$+" Is now Extracted ...",2)
60171 NEXT ARC.INDEX
CALL QTPUT ("Use the C)ompress command to create a ZIP file of Xtracted files",2)
GOTO 60140
'
' *** Added choice of Compressing file or taking it as is Pe 03/23/89 ***
'
60175 Subroutine.parameter = 1 'Pe 03/26/89
A$ = CRLF$ +"List files about to be Compressed (Y/[N])"
CALL TGET
IF SUBROUTINE.PARAMETER = -1 THEN _ 'Pe 03/29/88
EXIT SUB 'Pe 03/29/88
IF B$ ="N" or B$ = "n" Then _ 'Pe 04/07/89
GOTO 60179 'pe 04/07/89
IF B$ = "Y" or B$ = "y" THEN _ 'Pe 03/29/89
CALL QTPUT ("Creating file list, one moment please....",1): _
EXTRACT$ = "DIR "+ ARKVIEW.PATH$+">VUZIP"+NODE.ID$+".LST" : _
SHELL EXTRACT$ : _
CALL BUFFILE("VUZIP"+NODE.ID$ +".LST",X) : _
Subroutine.parameter = 1 : _ 'Pe 03/26/89
A$ = CRLF$ +"Continue with file Compression ([Y]/N) " : _
CALL TGET : _
IF SUBROUTINE.PARAMETER = -1 THEN _ 'Pe 03/29/88
EXIT SUB 'Pe 03/29/88
IF B$ = "N" or B$ = "n" THEN _ 'Pe 03/29/89
GOTO 60140
CALL QTPUT ("One Moment while I Compress the file(s) for you........",1)
'
'********** ARC all files in the ARKVIEW.PATH$ into VIEW.ZIP **********
'next line adds comment to Zip file if used EDIT to Suite and replace in 60179
'60179 ZIPME$ = LIBRARY.ARCHIVE.PATH$+"PKZIP -m -ex -z<C:\C3\MPL.CMT " + ARKVIEW.PATH$ + "\VIEW.ZIP " + ARKVIEW.PATH$ + "\*.*"
' old code
60179 ZIPME$ = LIBRARY.ARCHIVE.PATH$+"PKZIP -m -ex " + ARKVIEW.PATH$ + "\VIEW.ZIP " + ARKVIEW.PATH$ + "\*.*"
SHELL ZIPME$
' **** Check to see if Compresion was successfull if NOT then redo *****
VIEW.FILE.NAME$ = ARKVIEW.PATH$ + "\VIEW.ZIP" 'Pe 03/06/89
CALL FINDIT (VIEW.FILE.NAME$)
IF NOT OK THEN _
CALL QTPUT ( "No files to Compress...you must use the X)tract command first" ,2) : _
CALL DELAYIT (2) : _
GOTO 60140
'
'
'********** Tells the caller the name of the file to download **********
'
CALL QTPUT (" File has been Compressed and named... VIEW.ZIP....",2)
CALL QTPUT (CHR$(7)+"To Download this file You MUST enter VIEW.ZIP as the file name",2)
CALL DELAYIT (3)
GOTO 60140
60180 END SUB
'
64900 ' $SUBTITLE: 'RBBSPLAY -- subroutine to play music' ' KG122702
' $PAGE
'
' SUBROUTINE NAME -- RBBSPLAY
'
' INPUT PARAMETERS -- PARAMETER MEANING
' STRNG$ STRING TO PLAY
'
' OUTPUT PARAMETERS --
'
' SUBROUTINE PURPOSE -- PLAY MUSIC. SKIP IF GET AN ERROR.
'
SUB RBBSPLAY (STRNG.TO.PLAY$) STATIC ' KG122702
PLAY STRNG.TO.PLAY$ ' KG122702
EC = 0 ' KG122702
END SUB ' KG122702
' $SUBTITLE: 'Error Handling for separately compiled subroutines'
' $PAGE
'
' *****************************************************************************
' * Error handling for the separately compiled subroutines of RBBS-PC *
' *****************************************************************************
'
65000 IF DEBUG THEN _
A$ = "RBBSSUB1 DEBUG Error Trap Entry ERL=" + _
STR$(ERL) + _
" ERR=" + _
STR$(ERR) : _
IF PRINTER THEN _
CALL PRINTIT(A$) _
ELSE CALL LPRNT(A$,1)
EC = ERR
'
' SETCALL
'
IF ERL = 110 THEN _
RESUME NEXT
'
' OPEN CONFIG FILE
'
IF ERL => 117 AND ERL <= 118 THEN _
RESUME NEXT
'
' OPEN COM PORT ERROR HANDLING
'
IF ERL = 200 THEN _
CLS : _
CALL PSCRN (COM.PORT$ + " does not exit/not responding (Error" + STR$(ERR)) : _ ' KG120905
STOP
'
' GETCOM ERROR HANDLING
'
IF ERL = 1420 AND ERR = 57 THEN _
RESUME NEXT
IF ERL = 1420 AND ERR = 69 THEN _
SUBROUTINE.PARAMETER = -1 :_
RESUME NEXT
'
' OPENRESEQ ERROR HANDLING
'
IF ERL = 1481 THEN _
EC = ERR : _
RESUME NEXT
'
' OPENUSER ERROR HANDLING
'
IF ERL = 9400 AND ERR = 75 AND SHARE.IT THEN _
CALL DELAYIT (30) : _
RESUME
'
' FINDUSER ERROR HANDLING
'
IF ERL = 12610 THEN _
RESUME NEXT
'
' UPDTCALR ERROR HANDLING
'
IF ERL = 13663 THEN _
RESUME NEXT
IF ERL = 13672 AND ERR = 61 THEN _ 'KG102502
CALL QTPUT ("Disk Full",1) : _
IF DISKFULL.GO.OFFLINE THEN _
GOTO 65010 _
ELSE RESUME NEXT
IF ERL = 13672 THEN _ ' KG102502
CALLERS.FILE.INDEX! = CALLERS.FILE.INDEX! - 1 : _ ' KG102502
RESUME NEXT ' KG102502
'
' PRINTER ERROR HANDLING
'
IF ERL = 13674 THEN _
PRINTER = FALSE : _
RESUME
'
' CHANGEDIR ERROR HANDLING
'
IF ERL = 20103 THEN _
OK = FALSE : _
RESUME NEXT
'
' FINDIT ERROR HANDLING
'
IF ERL = 20221 THEN _
RESUME NEXT
IF ERL = 20223 AND EC = 58 THEN _
EC = 64 : _
OK = FALSE : _
RESUME NEXT
IF ERL = 20223 AND EC = 76 THEN _
CALL LPRNT("Bad path. File name is " + FILNAME$,1) : _
EC = 76 : _
OK = FALSE : _
RESUME NEXT
IF ERL => 20221 AND ERL <= 20223 AND EC = 70 _
AND NETWORK.TYPE = 6 THEN _
EC = 0 : _
RESUME NEXT
IF ERL => 20221 AND ERL <= 20223 THEN _
RESUME
'
' FLUSHCOM ERROR HANDLING
'
IF ERL = 20311 AND ERR = 57 THEN _
RESUME NEXT
IF ERL = 20311 AND ERR = 69 THEN _
ABORT = TRUE : _
SUBROUTINE.PARAMETER = -1 : _
RESUME NEXT
'
' NETBIOS ERROR HANDLING
'
IF ERL => 29900 AND ERL <= 29920 THEN _
RESUME NEXT
'
' UPDATEC ERROR HANDLING
'
IF ERL => 43050 AND ERL <= 43060 AND ERR = 61 THEN _
A$ = "* Disk full - terminating *" : _
SUBROUTINE.PARAMETER =2 : _
CALL TPUT : _
IF DISKFULL.GO.OFFLINE THEN _
GOTO 65010 _
ELSE SYSTEM
'
' CHECKINT ERROR HANDLING
'
IF ERL = 59652 AND ERR = 24 THEN _
NOT.CTS = TRUE : _
CALL LINE25 : _
RESUME
IF ERL => 52000 AND ERL <= 59660 THEN _ 'KG122702
RESUME NEXT
'
' VIEW ARC TXT ERROR HANDLER changed 60151 to 60149
'
IF ERL = 60149 AND ERR = 53 THEN _
CALL QTPUT ("ERROR !!! No Such File, EXITING",1):_
RESUME NEXT
IF ERL = 60149 AND ERR = 63 THEN _
CALL QTPUT ("ERROR Occured, Please notify SysOp",1):_
RESUME NEXT
'
'
' DLVIEW ARC TXT ERROR HANDLER
'
IF ERL = 60169 AND ERR = 53 THEN _
CALL QTPUT ("ERROR !!! No Such File, EXITING",1):_
RESUME NEXT
'
' VUZIP ERROR HANDLER
'
'IF ERL = 60175 THEN _ 'Pe 03/26/89
' RESUME NEXT 'Pe 03/26/89
'
'
' CATCH ALL OTHER ERRORS
'
A$ = "RBBS-SUB1 Untrapped Error" + _
STR$(ERR) + _
" in line" + _
STR$(ERL)
CALL QTPUT (A$,1)
CALL UPDTCALR (A$,2)
RESUME NEXT
' SHARED ROUTINE FOR GOING OFF LINE WHEN DISK FULL
65010 CALL OPENCOM(MODEM.INIT.BAUD$,",N,8,1")
CALL MODEMPUT (MODEM.GO.OFFHOOK.COMMAND$)
IF FOSSIL THEN _
CALL FOSEXIT(COMPORT%)
SYSTEM